perm filename MOVIT.F4[P11,LCS]1 blob
sn#570605 filedate 1981-03-09 generic text, type T, neo UTF8
C****** SUBRS MOVIT, OUTLMT, GETPTS, GUPDAT, DELETE, STFCH,COPYIT,CPYIT
SUBROUTINE MOVIT(RN,NP,R4,R5,R8,R9)
DIMENSION NP(1),RN(1)
COMMON /KJY/ NO,J
RDIS=(R9-R8)/(R5-R4)
DO 1 K=1,J
L=NP(K)
RA=RN(L)
IF(OUTLMT(R4,R5,RA))GO TO 1
IF(R9.NE.0)RA=(RA-R4)*RDIS
RN(L)=R8+RA
1 CONTINUE
END
FUNCTION OUTLMT(A,B,R)
C TELLS IF POINT IS WITHIN BOUNDS OF A-B (PUT THIS INTO MACRO)
OUTLMT=-1.
IF(R.LT.A)RETURN
IF(R.GT.B)RETURN
OUTLMT=0
END
SUBROUTINE GETPTS(NN)
C NN IS FIRST ITEM TO LOOK AT
INTEGER PWDS
COMMON/XRN/RN(1) /KJY/ K,J /POSI/STFF(8),JJ2
COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
1/PTR/PWDS(1) /RINP/R(500),N(350),NP(250) /LIMIT/LIM,ITEM
EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R6,RJQ(4))
J=0
K=0
C J AND K ARE COUNTERS FOR N AND NP ARRAYS.
DO 1 M=NN,ITEM
L=PWDS(M)
RY=RN(L+1)
IF(R2.GE.8)GO TO 3
C >=8 MEANS LOOK AT ALL STAVES
IF(R2.NE.RN(L+2))GO TO 1
C SKIP IF NOT RIGHT STAFF NUM.
3 IF(R6.LE.0)GO TO 9
C CHECK CODE NUM
IF(R6.NE.RY)GO TO 1
9 IF(OUTLMT(R4,R5,RN(L+3)))GO TO 2
C IN LIMITS?
CALL GUPDAT(M,L,3)
C GO PUT AWAY POINTER TO P3 OF THIS ITEM
K=K+1
NP(K)=L
C NP SAVES POINTER TO P3 FOR USE IN JUSTIFY ROUTINE
2 CNT=RN(L)
C GET THE WD CNT
IF(RY.EQ.2)GO TO 8
C FOR 'CENTERED' RESTS
IF(RY.LT.4)GO TO 1
IF(RY.GT.7)GO TO 1
IF(RY.EQ.6)GO TO 6
C TWO-ENDED ITEM?
7 IF(CNT.GT.3)GO TO 5
GO TO 1
6 IF(CNT.LT.8)GO TO 8
IF(RN(L+7).LT.0)GO TO 8
IF(RN(L+10).EQ.0)GO TO 8
IF(RN(L+8).LE.0)GO TO 8
C IGNORE P8 IF IT IS 0 OR -
IF(OUTLMT(R4,R5,RN(L+8)))GO TO 8
C IN LIMITS?
CALL GUPDAT(M,L,8)
C PUT AWAY POINTER TO P8 FOR THIS BEAM
8 IF(CNT.LT.7)GO TO 5
IF(RN(L+9).LE.0)GO TO 5
C WON'T LOOK AT NEG. POS.
IF(RY.EQ.2)GO TO 10
C (NEW REST CENTERING)
IF(RN(L+8).NE.0)GO TO 10
IF(RN(L+7).GE.0)GO TO 5
C USE R9 IF R9<0 AND (R8≠0 OR R7<0)
10 IF(OUTLMT(R4,R5,RN(L+9)))GO TO 1
C IN LIMITS?
CALL GUPDAT(M,L,9)
5 IF(RY.EQ.2)GO TO 1
IF(OUTLMT(R4,R5,RN(L+6)))GO TO 1
C IN LIMITS?
CALL GUPDAT(M,L,6)
C PUT AWAY POINTER TO P6 FOR ALL 2-SIDED ITEMS.
1 CONTINUE
END
SUBROUTINE GUPDAT(M,L,KK)
COMMON /KJY/ K,J /POSI/STFF(8),JJ2 /RINP/R(500),N(350),NP(250)
J=J+1
N(J)=L+KK
C SETS UP POINTERS FOR USE IN MOVES, ETC.
IF(M.LT.JJ2)JJ2=M
END
SUBROUTINE DELETE
IMPLICIT INTEGER(A-Q,S-Z)
COMMON/DL/X22,SAVER,NAME /XRN/RN(1)
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(15),R6,DEL,X,JY,K
COMMON/PTR/PWDS(1) /LIMIT/LIM,ITEM,L,I,IX
1 /DPY/ST(4000),MEDIT,IGO /DPTR/WDS(350)
EQUIVALENCE (ST2,ST(2))
IX=I
L=RN(MEDIT)+3
C SIZE OF DELETION
I=IX-L
CALL LOOP(MEDIT,I,1,0,L,RN)
JY=WDS(X22+1)-WDS(X22)
CALL LOOP(WDS(X22)+2,WDS(ITEM),1,0,JY,ST)
K=X22
194 N=K+1
WDS(N)=WDS(N+1)-JY
PWDS(K)=PWDS(N)-L
K=N
IF(K.LT.ITEM)GO TO 194
C ABOVE RESHUFFLES POINTER ARRAYS. X=ITEM+1
ITEM=ITEM-1
IF(X22.GT.ITEM)X22=ITEM
J2=ITEM
ITEM=ITEM-1
ST2=WDS(J2)
271 CALL DPYNEW
END
SUBROUTINE STFCH
CALL CPYIT(1)
END
SUBROUTINE COPYIT
CALL CPYIT(0)
END
SUBROUTINE CPYIT(KC)
INTEGER PWDS
COMMON/XRN/RN(1) /POSI/S(8),JJ2,P
COMMON R2,JA,CENTR,J2,RJQ(18),RX6,JR,L,RDIS,VY,JQ(17)
1/PTR/PWDS(1) /LIMIT/LIM,ITEM,LL,I,IX
EQUIVALENCE (R4,RJQ(2)),(R5,RJQ(3)),(R7,RJQ(5))
1,(R6,RJQ(4))
C KC IS FLAG FOR STFCH ROUTINE
IM=ITEM
DO 1 K=1,IM
L=PWDS(K)
IF(RTLINE(L))GO TO 1
IF(OUTLMT(R4,R5,RN(L+3)))GO TO 1
IF(R6.NE.0.AND.R6.NE.RN(L+1))GO TO 1
IF(KC.NE.0)GO TO 2
M=RN(L)+2
CALL LOOP(0,M,1,I,L,RN)
ITEM=ITEM+1
L=PWDS(ITEM)
2 IF(R7.LE.7.)RN(L+2)=R7
IF(KC.EQ.0)GO TO 3
IF(K.LT.JJ2)JJ2=K
GO TO 1
3 IF(ITEM.LT.JJ2)JJ2=ITEM
I=I+M+1
PWDS(ITEM+1)=I
1 CONTINUE
IF(KC.EQ.0)R2=R7
END